perm filename BRAKE.14[AID,LSP]1 blob sn#418532 filedate 1979-02-12 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(DECLARE (*FEXPR BRAKE UNBRAKE %DATA-INIT)
C00012 ENDMK
C⊗;
(DECLARE (*FEXPR BRAKE UNBRAKE %DATA-INIT)
	   (SPECIAL %TOP-EDIT-EXP %#CE W %BROKEN-FNS% %single-broken%))

(DEFUN %IOG% MACRO (X) 
       ;; simulates the losing IOG function.
       ;; actually simulates Finin's losing IOG simulator
       (PROG (↑CHAR LIST-OF-TS TEMP)
	     (DO ((CH (EXPLODE (CADR X)) (CDR CH)))
		 ((NULL CH))
		 (SETQ TEMP (ASSQ (CAR CH) 
		  '((V W NIL) (W W T) (R R T) (T R NIL) (Q Q T) (S Q NIL))))
		 (OR TEMP (ERROR '|Nasty losing IOG error| (CAR CH)))
		 (PUSH (IMPLODE (LIST '↑ (CADR TEMP))) ↑CHAR)
		 (PUSH (CADDR TEMP) LIST-OF-TS))
	     (RETURN (CONS (CONS 'LAMBDA (CONS ↑CHAR (CDDR X)))
			   LIST-OF-TS)))) 


(EVAL-WHEN (LOAD EVAL COMPILE)
 (COND ((STATUS FEATURES NEWIO)
	(DEFUN VERSION MACRO (X)
	       (list 'quote (caddr (namelist infile)))))
       (T (DEFUN VERSION MACRO (X)(LIST 'QUOTE (CADR (STATUS UREAD)))))))

(DEFUN %BRAKE-LOAD-MSG NIL
	(OR (STATUS FEATURE NOLDMSG)
	    ((LAMBDA(↑R)
		(TERPRI)
	    	(PRINC '|;loading BRAKE.|)
	    	(PRINC (VERSION))
		(PRINC '| |)
		(TERPRI))
	     NIL)))

(%BRAKE-LOAD-MSG)

(SETQ %BROKEN-FNS% NIL %single-broken% nil)

;;; Brakes multiple functions

(defun brk fexpr (forms)
 (append (mapcar (function (lambda (q) (brk1 q t))) forms) '(broken)))

(defun brakeif fexpr (forms)
 (apply 'brk1 forms)
 (list (car forms) 'broken))

(defun brk1 (form pred)
 (prog (type lam)
  (cond ((setq lam (get form 'expr))(setq type 'expr))
	((setq lam (get  form 'fexpr))(setq type 'fexpr)) 
	(t (princ '|Huh?|)(terpri)(return 'nothing)))
  ((lambda (place)
   (cond ((memq form %single-broken%)
	  (terpri)
	  (princ form) (princ '| already broken!|)(terpri)
	  (cond ((eq (car (cadr place)) 'break))
		(t (princ '|However, it's not really broken! So here goes...|)
		   (terpri)
		   (rplacd place (cons (list 'break form pred) (cdr place)))))) 
	 (t
	  (rplacd place (cons (list 'break form pred) (cdr place))) 
	  (setq %single-broken% (cons form %single-broken%)))))
   (cdr lam))
  (return  form)))

(defun unbrk fexpr (forms)
 (append 
  (mapcar 'unbrk1 (cond (forms)
		 	(t %single-broken%))) '(unbroken)))

(defun unbrk1 (form)
 (and (memq form %single-broken%)
 (prog (type lam)
  (cond ((setq lam (get form 'expr))(setq type 'expr))
	((setq lam (get  form 'fexpr))(setq  type 'fexpr))  
	(t (princ '|Huh?|)(terpri)(return 'nothing)))
  (cond ((eq (car (caddr lam)) 'break)
  	 (rplacd (cdr lam) (cdddr lam))
  	 (setq %single-broken% (delete  form %single-broken%))
  	 (return  form))    
	(t (princ '|Huh?|)(terpri)(return 'nothing)))))) 

 
(DEFUN BRAKE FEXPR (FORM) 
 (cond ((zerop (length form))
	(append %broken-fns% %single-broken%))
       ((= (length form) 1) (apply 'brk form))
       (t 
       (PROG (FUNAME NUMBER PATTERN CONDITION POSITION BREAK) 
	     (SETQ FORM (CONS NIL FORM))
	     (COND ((NULL (SETQ FUNAME (OR (GET FORM 'IN)
					   (PROGN (SETQ FORM (CDR FORM))
						  (CAR  FORM)))))
		    (SETQ FUNAME (%GETNAME %TOP-EDIT-EXP)))
		   (T ((LAMBDA(DRAFT)
			(REMPROP FUNAME 'DRAFT)
			(APPLY '%DATA-INIT (LIST FUNAME))
			(PUTPROP FUNAME DRAFT 'DRAFT))
		        (GET FUNAME 'DRAFT))))
	     (SETQ NUMBER (OR (GET FORM 'NUMBER) 1.) 
		   CONDITION (OR (GET FORM 'IF) T) 
		   POSITION (CAR (OR (MEMBER 'AFTER FORM)
				     (MEMBER 'BEFORE FORM))) 
		   PATTERN (GET FORM POSITION))
	     (COND ((NULL PATTERN) 
		    (RETURN (LIST (BRK1 FUNAME CONDITION) 'BROKEN)))) 
	     (OR (MEMQ FUNAME %BROKEN-FNS%) 
		 (SETQ %BROKEN-FNS% (CONS FUNAME %BROKEN-FNS%)))
	     (%EVALUATE 'TOP)
	     (SETQ BREAK (LIST 'BREAK
			       (LIST 'IN
				     FUNAME
				     POSITION
				     PATTERN
				     'NUMBER
				     NUMBER)
			       CONDITION))
	     (RETURN (COND ((NULL (%EVALUATE (LIST 'F
						   PATTERN
						   NUMBER)))
			    'WHERE??)
			   ((ATOM PATTERN) 
				(%EVALUATE 
					       (COND ((EQUAL POSITION
							     'AFTER)
						      (LIST 'AI BREAK))
						     ((LIST 'BI BREAK))))
			      (%IOG% W
				   (SETQ ↑W T)
				   (%EVALUATE 'OK))
			      (%EVALUATE 'TOP)
			      (LIST FUNAME 'BROKEN))
			   (T (%EVALUATE (LIST 'CR
					       (COND ((EQUAL POSITION
							     'AFTER)
						      (LIST 'PROG2
							    NIL
							    %#CE
							    BREAK))
						     ((LIST 'PROG2
							    BREAK
							    %#CE)))))
			      (%IOG% W
				   (SETQ ↑W T)
				   (%EVALUATE 'OK))
			      (%EVALUATE 'TOP)
			      (LIST FUNAME 'BROKEN))))))))

(defun %remdup (l)
 (cond ((null l) nil)
       ((memq (car l) (cdr l)) (%remdup (cdr l)))
       (t (cons (car l)(%remdup (cdr l))))))

(DEFUN UNBRAKE FEXPR (FORM) 
     (%remdup
	     (COND 
		   ((EQ (CAR FORM) '*) (APPEND 
					(MAPCAR 'UNBRAKE1 (APPEND 
							   %SINGLE-BROKEN%
							   %BROKEN-FNS%)) 
					'(UNBROKEN))) 
		   (T  (APPEND
			(MAPCAR 'UNBRAKE1 (cond (FORM)
						(t (append %broken-fns% 
							   %single-broken%)))) 
			'(UNBROKEN))) )))

(DEFUN UNBRAKE1 (FORM)
 (COND ((MEMQ FORM %SINGLE-BROKEN%)(UNBRK1 FORM))
       ((memq form %broken-fns%)
       (PROG (?FORM) 
	     (COND (FORM (APPLY '%DATA-INIT FORM)))
	     (SETQ %BROKEN-FNS% (DELETE (%GETNAME %TOP-EDIT-EXP) %BROKEN-FNS%))
	     (%EVALUATE 'TOP)
	     (RETURN (DO NIL
			 ((NULL (%EVALUATE '(F (BREAK (IN ?
							  ?
							  ?
							  NUMBER
							  ?)
						      ?))))
			  (%EVALUATE 'TOP)
			  (%IOG% W (SETQ ↑W T) (%EVALUATE 'OK))
			  (%GETNAME %TOP-EDIT-EXP))
			 (%EVALUATE '↑)
			 (COND ((OR (%MATCH '(PROG2 (BREAK ? ?) ?FORM)
					  %#CE)
				  (%MATCH '(PROG2 NIL
						  ?FORM
						  (BREAK ? ?))
					  %#CE))
			      (%EVALUATE '(PR ?FORM)))      
			      (T (%EVALUATE '(F (BREAK (IN ? ? ? NUMBER ?) ?)))
				 (%EVALUATE 'DELETE)))))   ))  
      (t (princ '|Huh?|)(terpri) 'nothing)))